COMMENT ā VALID 00014 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 C *** ORDER COMPILATION PROGRAM FOR COOPERATIVES (299 CARDS, LAST=#299) CP 1
C00011 00003 READ 5050, CODEX(I), NAMEX(I,1), NAMEX(I,2), UNITX(I), CP 56
C00019 00004 PRINT 5140, CATX CP 115
C00027 00005 IF (K.EQ.0) GO TO 360 CP 174
C00035 00006 L=5 CP 233
C00042 00007 SUBROUTINE ERRCHK (I, *) CP 287
C00044 00008 C *** BILLING PROGRAM FOR COOPERATIVES (390 CARDS, LAST = #390) BP 1
C00051 00009 DO 65 I=1,NACCTS BP 56
C00059 00010 M=MXPROD*(MXACCT+6)/7 BP 115
C00067 00011 2 UNITX(K), PRICE(K), FACTOR(K), K=L,L3,54) BP 174
C00075 00012 DO 455 L=L1,L2 BP 233
C00083 00013 PRINT 5290, BALNCE(I) BP 292
C00091 00014 5185 FORMAT (1X, I3, 3X, A8, A5, 16X, F8.2) BP 351
C00097 ENDMK
Cā;
C *** ORDER COMPILATION PROGRAM FOR COOPERATIVES (299 CARDS, LAST=#299) CP 1
C COPYRIGHT (C) 1975 BY CHARLES H. SPALDING III CP 2
LOGICAL ERROR CP 3
INTEGER*2 BAGQ(150), BUY(150), I, J, K, L, L1, L2, L3, L4, CP 4
2 L5, M, M1, M2, M3, MT(5), MXACCT, MXCAT, MXNOTE, MXPROD, CP 5
3 N, N1, N2, NACCTS, NCATS, NK, NNOTES, NPRODS, NT, NUM(8), CP 6
4 ORDER(200,150), P, PACK(2,200), PMAX, Q, QUAN(19) CP 7
REAL AMT(8), BLANKX, CATCDX(10), CATX, CODEX(150), ITEMX(19), CP 8
2 LABELX, LIST(10,200), PREFIX, PRICE(150), TEMP, CP 9
3 WORDX(3), ZEROX CP 10
DOUBLE PRECISION COOPX(8), DATEX, EXS, PINFOX(150,5), CP 11
2 MEM(5,2), MEMBRX(200,2), NAMEX(150,2), TEMPX(5), CP 12
3 T1X, T2X, T3X, UNITX(150), ZEROSX CP 13
DATA BLANKX/' '/, BUY/150*0/, ERROR/.FALSE./, EXS/' '/, CP 14
2 LIST/2000*0.0/, MEMBRX/400*' '/, ORDER/30000*0/, CP 15
3 PACK/400*0/, WORDX/'WORK','FILE','WORK'/, ZEROX/'00'/, CP 16
4 ZEROSX/'00'/ CP 17
MXACCT=200 CP 18
MXCAT =10 CP 19
MXPROD=150 CP 20
C * READ COOP INFORMATION CP 21
READ 5000, PREFIX, COOPX CP 22
PRINT 5010, COOPX CP 23
C * READ ACCOUNTING LIST CATEGORIES (READ CODE, IGNORE REST) CP 24
DO 10 I=1,MXCAT CP 25
READ 5020, CATCDX(I) CP 26
IF (CATCDX(I).NE.ZEROX) GO TO 10 CP 27
NCATS=I-1 CP 28
GO TO 20 CP 29
10 CONTINUE CP 30
CALL ERRCHK (1, &250) CP 31
NCATS=MXCAT CP 32
C * READ MEMBERSHIP FILE (PREFIX, ACCT. NO., NAME, IGNORE REST) CP 33
20 NACCTS=0 CP 34
DO 40 I=1,MXACCT CP 35
READ 5030, CATX, N1, T1X, T2X, TEMP CP 36
IF (N1.EQ.0) GO TO 50 CP 37
IF (CATX.EQ.PREFIX) GO TO 25 CP 38
PRINT 5035, N1, CATX CP 39
ERROR=.TRUE. CP 40
25 IF (N1.LE.MXACCT) GO TO 26 CP 41
PRINT 5035, N1, CATX CP 42
ERROR=.TRUE. CP 43
GO TO 40 CP 44
26 IF (MEMBRX(N1,1).EQ.EXS) GO TO 30 CP 45
PRINT 5040, N1 CP 46
ERROR=.TRUE. CP 47
GO TO 40 CP 48
30 IF (N1.GT.NACCTS) NACCTS=N1 CP 49
MEMBRX(N1,1)=T1X CP 50
MEMBRX(N1,2)=T2X CP 51
40 CONTINUE CP 52
CALL ERRCHK (2, &250) CP 53
C * READ PRODUCT FILE (CODE, NAME, UNITS, BAG INFO, PRICE, NOTE) CP 54
50 DO 85 I=1,MXPROD CP 55
READ 5050, CODEX(I), NAMEX(I,1), NAMEX(I,2), UNITX(I), CP 56
2 BAGQ(I), PRICE(I), TEMPX CP 57
IF (CODEX(I).NE.ZEROX) GO TO 60 CP 58
NPRODS=I-1 CP 59
GO TO 90 CP 60
60 IF (I.EQ.1) GO TO 75 CP 61
K=I-1 CP 62
DO 70 J=1,K CP 63
IF (CODEX(I).NE.CODEX(J)) GO TO 70 CP 64
PRINT 5060, CODEX(I) CP 65
ERROR=.TRUE. CP 66
GO TO 85 CP 67
70 CONTINUE CP 68
75 DO 80 J=1,5 CP 69
80 PINFOX(I,J)=TEMPX(J) CP 70
85 CONTINUE CP 71
CALL ERRCHK (3, &250) CP 72
NPRODS=MXPROD CP 73
C * READ DATE TO BE ON OUTPUT CP 74
90 READ 5070, DATEX CP 75
C * READ ORDERS (ACCT, CODE, QUANTITY, ...) CP 76
M=MXACCT*(MXPROD+18)/19 CP 77
DO 150 I=1,M CP 78
READ 5080, NT, (ITEMX(J), QUAN(J), J=1,19) CP 79
IF (NT.EQ.0) GO TO 160 CP 80
IF (NT.GT.MXACCT) GO TO 100 CP 81
IF (MEMBRX(NT,1).NE.EXS) GO TO 110 CP 82
100 PRINT 5090, NT CP 83
ERROR=.TRUE. CP 84
IF (NT.GT.MXACCT) GO TO 150 CP 85
110 N=0 CP 86
DO 140 J=1,19 CP 87
IF (ITEMX(J).EQ.BLANKX) GO TO 140 CP 88
DO 130 K=1,NPRODS CP 89
N=N+1 CP 90
IF (N.GT.NPRODS) N=1 CP 91
IF (ITEMX(J).NE.CODEX(N)) GO TO 130 CP 92
IF (ORDER(NT,N).EQ.0) GO TO 120 CP 93
PRINT 5100, NT, CODEX(N) CP 94
ERROR=.TRUE. CP 95
GO TO 140 CP 96
120 ORDER(NT,N)=QUAN(J) CP 97
BUY(N)=BUY(N)+QUAN(J) CP 98
GO TO 140 CP 99
130 CONTINUE CP 100
PRINT 5110, NT, ITEMX(J) CP 101
ERROR=.TRUE. CP 102
140 CONTINUE CP 103
150 CONTINUE CP 104
CALL ERRCHK (4, &250) CP 105
C * READ ACCOUNTING LISTS (CODE, ACCT, AMOUNT, ...) CP 106
160 PRINT 5120 CP 107
M=MXCAT*(MXACCT+6)/7 CP 108
DO 230 I=1,M CP 109
READ 5130, CATX, (NUM(J), AMT(J), J=1,7) CP 110
IF (CATX.EQ.ZEROX) GO TO 240 CP 111
DO 220 J=1,NCATS CP 112
IF (CATX.EQ.CATCDX(J)) GO TO 170 CP 113
IF (J.NE.NCATS) GO TO 220 CP 114
PRINT 5140, CATX CP 115
ERROR=.TRUE. CP 116
170 DO 210 K=1,7 CP 117
N=NUM(K) CP 118
IF (N.EQ.0) GO TO 210 CP 119
IF (N.GT.MXACCT) GO TO 180 CP 120
IF (MEMBRX(N,1).NE.EXS) GO TO 190 CP 121
180 PRINT 5150, CATX, N CP 122
ERROR=.TRUE. CP 123
IF (N.GT.MXACCT) GO TO 210 CP 124
190 IF (LIST(J,N).EQ.0.0) GO TO 200 CP 125
PRINT 5160, CATX, N CP 126
ERROR=.TRUE. CP 127
200 LIST(J,N)=AMT(K) CP 128
210 CONTINUE CP 129
GO TO 230 CP 130
220 CONTINUE CP 131
230 CONTINUE CP 132
CALL ERRCHK (5, &240) CP 133
C * STOP IF FATAL ERROR(S) DETECTED CP 134
240 IF (.NOT.ERROR) GO TO 260 CP 135
250 PRINT 5170 CP 136
STOP CP 137
260 PRINT 5180 CP 138
C * PRINT BUYING LIST CP 139
DO 270 I=1,NPRODS CP 140
IF (PRICE(I).LT.-0.0001) BUY(I)=0 CP 141
270 CONTINUE CP 142
PMAX=(NPRODS-1)/112+1 CP 143
C TO GET 1 OR 2 "WORK" COPIES MAKE THE LAST DIGIT IN THE CP 144
C FOLLOWING STATEMENT 2 OR 3, RESPECTIVELY. CP 145
DO 320 I=1,2 CP 146
LABELX=WORDX(I) CP 147
280 DO 310 P=1,PMAX CP 148
PRINT 5190, DATEX, LABELX, P, PMAX, COOPX CP 149
L1=112*(P-1)+1 CP 150
L2=L1+55 CP 151
DO 300 L=L1,L2 CP 152
IF (L.GT.NPRODS) GO TO 320 CP 153
L3=L+56 CP 154
IF (L3.GT.NPRODS) GO TO 290 CP 155
PRINT 5200, (NAMEX(K,1), NAMEX(K,2), BUY(K), CP 156
2 UNITX(K), PRICE(K), K=L,L3,56) CP 157
GO TO 300 CP 158
290 PRINT 5200, NAMEX(L,1), NAMEX(L,2), BUY(L), CP 159
2 UNITX(L), PRICE(L) CP 160
300 CONTINUE CP 161
310 CONTINUE CP 162
320 CONTINUE CP 163
C * PRINT PACKING LISTS CP 164
M=0 CP 165
DO 360 I=1,NPRODS CP 166
IF (PRICE(I).LT.-0.0001) GO TO 360 CP 167
K=0 CP 168
DO 330 J=1,NACCTS CP 169
IF (ORDER(J,I).EQ.0) GO TO 330 CP 170
K=K+1 CP 171
PACK(1,K)=J CP 172
330 CONTINUE CP 173
IF (K.EQ.0) GO TO 360 CP 174
M=M+1 CP 175
PRINT 5240 CP 176
IF (PINFOX(I,1).NE.EXS) PRINT 5205, (PINFOX(I,J),J=1,5) CP 177
PRINT 5210, NAMEX(I,1), NAMEX(I,2), UNITX(I), CP 178
2 DATEX, COOPX, CODEX(I), M CP 179
NK=K/2 CP 180
N=NK CP 181
IF (2*N.NE.K) N=N+1 CP 182
IF (NK.EQ.0) GO TO 350 CP 183
DO 340 J=1,NK CP 184
L=J+N CP 185
M1=PACK(1,J) CP 186
M2=PACK(1,L) CP 187
M3=M2-M1 CP 188
340 PRINT 5220, (ORDER(L,I), L, MEMBRX(L,1), CP 189
2 MEMBRX(L,2), L=M1,M2,M3) CP 190
350 IF (N.EQ.NK) GO TO 360 CP 191
M1=PACK(1,N) CP 192
PRINT 5230, ORDER(M1,I), M1, MEMBRX(M1,1), CP 193
2 MEMBRX(M1,2) CP 194
360 CONTINUE CP 195
PRINT 5240 CP 196
C * PRINT PACKING LABELS (FOR PREPACKAGED ITEMS) CP 197
N=0 CP 198
DO 430 I=1,NPRODS CP 199
IF (PRICE(I).LT.-0.0001) GO TO 430 CP 200
IF (BAGQ(I).EQ.0) GO TO 430 CP 201
K=0 CP 202
DO 390 J=1,NACCTS CP 203
Q=ORDER(J,I) CP 204
IF (Q.EQ.0) GO TO 390 CP 205
370 K=K+1 CP 206
PACK(1,K)=J CP 207
IF (Q.LE.BAGQ(I)) GO TO 380 CP 208
PACK(2,K)=BAGQ(I) CP 209
Q=Q-BAGQ(I) CP 210
GO TO 370 CP 211
380 PACK(2,K)=Q CP 212
390 CONTINUE CP 213
IF (K.EQ.0) GO TO 430 CP 214
N=N+1 CP 215
IF (N.GT.1) PRINT 5250 CP 216
PRINT 5255 CP 217
T1X=UNITX(I) CP 218
T2X=NAMEX(I,1) CP 219
T3X=NAMEX(I,2) CP 220
L1=(K-1)/5+1 CP 221
DO 420 J=1,L1 CP 222
L2=5*(J-1) CP 223
L3=L2+1 CP 224
DO 400 L=1,5 CP 225
L4=L2+L CP 226
MT(L)=PACK(1,L4) CP 227
M=MT(L) CP 228
MEM(L,1)=MEMBRX(M,1) CP 229
MEM(L,2)=MEMBRX(M,2) CP 230
IF (L4.EQ.K) GO TO 410 CP 231
400 CONTINUE CP 232
L=5 CP 233
410 PRINT 5260, (PACK(2,M), T1X, DATEX, M=L3,L4) CP 234
PRINT 5270, (T2X, T3X, M=1,L) CP 235
420 PRINT 5280, (PREFIX,MT(M),MEM(M,1),MEM(M,2),M=1,L) CP 236
430 CONTINUE CP 237
PRINT 5240 CP 238
STOP CP 239
5000 FORMAT (A3, 7A8, A5/) CP 240
5010 FORMAT ('0'/'0', 9X, 'ERROR MESSAGES FOR ORDER COMPILATION ', CP 241
2 'RUN FOR ', 8A8/'0') CP 242
5020 FORMAT (A2) CP 243
5030 FORMAT (A3, I3, 1X, 2A8, 40X, F7.2) CP 244
5035 FORMAT ('0', 25X, 'MEMBERSHIP FILE CONTAINS ACCOUNT #', I3, CP 245
2 ' WITH PREFIX "', A3, '"') CP 246
5040 FORMAT ('0', 25X, 'MEMBERSHIP FILE CONTAINS ACCOUNT #', I3, CP 247
2 ' MORE THAN ONCE') CP 248
5050 FORMAT (A2, 1X, 2A8, 1X, A6, I2, 5X, F6.3, 1X, 5A8) CP 249
5060 FORMAT ('0', 25X, 'PRODUCT FILE CONTAINS PRODUCT CODE "', CP 250
2 A2, '" MORE THAN ONCE') CP 251
5070 FORMAT (A8/) CP 252
5080 FORMAT (I3, 1X, 19(A2, I2)) CP 253
5090 FORMAT ('0', 25X, 'ACCOUNT #', I3, ' ORDERED - THIS ', CP 254
2 'ACCOUNT IS INACTIVE') CP 255
5100 FORMAT ('0', 25X, 'ACCOUNT #', I3, ' ORDERED ITEM "', A2, CP 256
2 '" MORE THAN ONCE') CP 257
5110 FORMAT ('0', 25X, 'ACCOUNT #', I3, ' ORDERED ITEM "', A2, CP 258
2 '" WHICH IS NOT DEFINED') CP 259
5120 FORMAT ('0') CP 260
5130 FORMAT (A2, 1X, 7(I3, 1X, F6.5)) CP 261
5140 FORMAT ('0', 25X, 'ACCOUNTING LIST CODE "', A2, CP 262
2 '" WAS USED - THIS CODE WAS NOT DEFINED') CP 263
5150 FORMAT ('0', 25X, 'ACCOUNTING LIST "', A2, '" CONTAINS ', CP 264
2 'ACCOUNT #', I3, ' WHICH IS INACTIVE') CP 265
5160 FORMAT ('0', 25X, 'ACCOUNTING LIST "', A2, '" CONTAINS ', CP 266
2 'ACCOUNT #', I3, ' MORE THAN ONCE') CP 267
5170 FORMAT ('0'/'0'/10X, 'END OF ERROR LIST -- PROGRAM IS ', CP 268
2 'STOPPING -- CORRECT DATA AND RE-RUN'/'1') CP 269
5180 FORMAT (10X, 'NO ERRORS WERE DETECTED') CP 270
5190 FORMAT ('1'/' BUYING LIST FOR ', A8, 9X, '(', A4, CP 271
2 ' COPY, PAGE', I2, ' OF', I2, ')', 9X, 8A8/'0') CP 272
5200 FORMAT (2(14X, 2A8, I5, 3X, A6, ' (', F6.3, ' )', 5X)) CP 273
5205 FORMAT (' ', 38X, '*** NOTE TO PACKER - ', 5A8//) CP 274
5210 FORMAT (' ', 5X, 2A8, ' BY THE ', A6, ' (', A8, ') ', CP 275
2 8A8, 7X, '(', A2, ') ', I3//'0', 2(18X, 'MISSING', CP 276
3 ' QUANTITY ACCT NAME', 9X)) CP 277
5220 FORMAT ('0'/4X, 2(16X, '_____', I9, ' ->', I5, 4X, 2A8)) CP 278
5230 FORMAT ('0'/20X, '_____', I9, ' ->', I5, 4X, 2A8) CP 279
5240 FORMAT ('1') CP 280
5250 FORMAT (' ') CP 281
5255 FORMAT ('0', 132('_')) CP 282
5260 FORMAT (//'0', I2, 1X, A6, 7X, A8, 4(3X, I2, 1X, A6, 7X, A8)) CP 283
5270 FORMAT (9X, 2A8, 4(11X, 2A8)) CP 284
5280 FORMAT (1X, A3, I3, ': ', 2A8, 4(3X, A3, I3, ': ', 2A8)) CP 285
END CP 286
SUBROUTINE ERRCHK (I, *) CP 287
REAL A, WORDS(3,7), ZEROX CP 288
DATA WORDS/'LIST', ' HEA', 'DING', ' MEM', 'BERS', 'HIP ', CP 289
2 ' P', 'RODU', 'CT ', ' ', 'ORDE', 'R ', CP 290
3 'ACCT', 'ING ', 'LIST', 'ORDE', 'R CH', 'ANGE', CP 291
4 ' ', 'NOTE', ' '/, ZEROX/'00'/ CP 292
READ 5000, A CP 293
IF (A.EQ.ZEROX) RETURN CP 294
PRINT 5010, (WORDS(J,I), J=1,3) CP 295
RETURN 1 CP 296
5000 FORMAT (A2) CP 297
5010 FORMAT ('0'/'0', 25X, 'TOO MANY ', 3A4, ' CARDS IN THE DATA') CP 298
END CP 299
C *** BILLING PROGRAM FOR COOPERATIVES (390 CARDS, LAST = #390) BP 1
C COPYRIGHT (C) 1975 BY CHARLES H. SPALDING III BP 2
LOGICAL ERROR, NOCATS, NOTES, RESET BP 3
INTEGER*2 COST(200,150), DIGITX(10), FLAGX, I, J, K, L, L1, BP 4
2 L2, L3, L4, L5, LINES(200), M, M1, M2, M3, MCNT(200), BP 5
3 MXACCT, MXCAT, MXNOTE, MXPROD, N, N1, N2, NACCTS, BP 6
4 NCATS, NK, NLIM, NNOTES, NPRODS, NT, NUM(8), BP 7
5 ORDER(200,150), P, PMAX, Q, QUAN(19) BP 8
REAL AMT(8), BALNCE(200), BLANKX, CATCDX(10), CATX, BP 9
2 CODEX(150), CST, CTGRYX(10,5), CUMM(200), DLIM, BP 10
3 FACTOR(150), ITEMX(19), LABELX, LIST(10,200), MARKUP, BP 11
4 MINUSX, NEW(200), PERCNT, PREFIX, PRICE(150), SELL(150), BP 12
5 SIGN(10), SIGNX(10), T1(3), TOTAL(200), WORDX(2), ZEROX BP 13
DOUBLE PRECISION COOPX(8), DATEX, EXS, INFOX(200,5), BP 14
2 MEMBRX(200,2), NAMEX(150,2), NOTEX(10,8), T1X, BP 15
3 T2X, T3X, UNITX(150), ZEROSX BP 16
DATA BALNCE/200*0.0/, BLANKX/' '/, CUMM/200*0.0/, DIGITX/'1', BP 17
2 '2', '3', '4', '5', '6', '7', '8', '9', '#'/, BP 18
3 ERROR/.FALSE./, EXS/' '/, INFOX/1000*' '/, LIST/2000*0./, BP 19
4 MCNT/200*0/, MINUSX/'-'/, MEMBRX/400*' '/, NEW/200*0.0/, BP 20
5 NOCATS, NOTES/2*.FALSE./, ORDER/30000*0/, SIGN/10*1./, BP 21
6 WORDX/'WORK', 'FILE'/, ZEROX/'00'/, ZEROSX/'00'/ BP 22
MXACCT=200 BP 23
MXCAT =10 BP 24
MXNOTE=10 BP 25
MXPROD=150 BP 26
C * READ COOP INFORMATION CARD BP 27
READ 5000, PREFIX, COOPX, PERCNT, DLIM, NLIM, RESET BP 28
PRINT 5010, COOPX BP 29
C * READ ACCOUNTING LIST CATEGORIES (CODE, SIGN, HEADING) BP 30
DO 30 I=1,MXCAT BP 31
READ 5020, CATCDX(I), SIGNX(I), (CTGRYX(I,J), J=1,5) BP 32
IF (CATCDX(I).NE.ZEROX) GO TO 10 BP 33
NCATS=I-1 BP 34
IF (NCATS.EQ.0) NOCATS=.TRUE. BP 35
GO TO 40 BP 36
10 IF (SIGNX(I).EQ.MINUSX) SIGN(I)=-1. BP 37
30 CONTINUE BP 38
NCATS=MXCAT BP 39
C * READ MEMBERSHIP FILE CARDS BP 40
40 NACCTS=0 BP 41
DO 50 I=1,MXACCT BP 42
READ 5030, CATX, N1, T1X, T2X, (NOTEX(1,J), J=1,5), BP 43
2 T1(1), N2, T1(2) BP 44
IF (N1.EQ.0) GO TO 60 BP 45
IF (N1.GT.NACCTS) NACCTS=N1 BP 46
MEMBRX(N1,1)=T1X BP 47
MEMBRX(N1,2)=T2X BP 48
BALNCE(N1)=T1(1) BP 49
MCNT(N1)=N2 BP 50
CUMM(N1)=T1(2) BP 51
DO 50 J=1,5 BP 52
INFOX(N1,J)=NOTEX(1,J) BP 53
50 CONTINUE BP 54
60 IF (.NOT.RESET .OR. NOCATS) GO TO 70 BP 55
DO 65 I=1,NACCTS BP 56
65 CUMM(I)=0.0 BP 57
C * READ PRODUCT FILE (CODE, NAME, UNITS, % MARKUP, PRICE) BP 58
70 DO 90 I=1,MXPROD BP 59
READ 5040, CODEX(I), NAMEX(I,1), NAMEX(I,2), UNITX(I), BP 60
2 FACTOR(I), PRICE(I) BP 61
IF (CODEX(I).NE.ZEROX) GO TO 80 BP 62
NPRODS=I-1 BP 63
GO TO 100 BP 64
80 IF (FACTOR(I).EQ.0.0) FACTOR(I)=PERCNT BP 65
90 CONTINUE BP 66
NPRODS=MXPROD BP 67
C * READ DATE TO BE ON BILLS BP 68
100 READ 5050, DATEX BP 69
C * READ ORDERS (ACCT, CODE, QUANTITY, ...) BP 70
M=MXACCT*(MXPROD+18)/19 BP 71
DO 120 I=1,M BP 72
READ 5060, NT, (ITEMX(J), QUAN(J), J=1,19) BP 73
IF (NT.EQ.0) GO TO 125 BP 74
N=0 BP 75
DO 120 J=1,19 BP 76
IF (ITEMX(J).EQ.BLANKX) GO TO 120 BP 77
DO 110 K=1,NPRODS BP 78
N=N+1 BP 79
IF (N.GT.NPRODS) N=1 BP 80
IF (ITEMX(J).NE.CODEX(N)) GO TO 110 BP 81
ORDER(NT,N)=QUAN(J) BP 82
GO TO 120 BP 83
110 CONTINUE BP 84
120 CONTINUE BP 85
C * READ ACCOUNTING LISTS (CODE, ACCT, AMOUNT, ...) BP 86
125 M=MXCAT*(MXACCT+6)/7 BP 87
DO 170 I=1,M BP 88
READ 5070, CATX, (NUM(J), AMT(J), J=1,7) BP 89
IF (CATX.EQ.ZEROX) GO TO 180 BP 90
DO 160 J=1,NCATS BP 91
IF (CATX.EQ.CATCDX(J)) GO TO 130 BP 92
IF (J.NE.NCATS) GO TO 160 BP 93
PRINT 5071, CATX BP 94
ERROR=.TRUE. BP 95
130 DO 150 K=1,7 BP 96
N=NUM(K) BP 97
IF (N.EQ.0) GO TO 150 BP 98
IF (N.GT.MXACCT) GO TO 135 BP 99
IF (MEMBRX(N,1).NE.EXS) GO TO 140 BP 100
135 PRINT 5072, CATX, N BP 101
ERROR=.TRUE. BP 102
IF (N.GT.MXACCT) GO TO 150 BP 103
140 IF (LIST(J,N).EQ.0.0) GO TO 145 BP 104
PRINT 5073, CATX, N BP 105
ERROR=.TRUE. BP 106
145 LIST(J,N)=AMT(K) BP 107
150 CONTINUE BP 108
GO TO 170 BP 109
160 CONTINUE BP 110
170 CONTINUE BP 111
CALL ERRCHK (5, &290) BP 112
C * READ ORDER CHANGES BP 113
180 PRINT 5065 BP 114
M=MXPROD*(MXACCT+6)/7 BP 115
DO 250 I=1,M BP 116
READ 5080, CATX, (NUM(J), QUAN(J), QUAN(J+7), J=1,7) BP 117
IF (CATX.EQ.ZEROX) GO TO 260 BP 118
DO 240 J=1,NPRODS BP 119
IF (CATX.EQ.CODEX(J)) GO TO 190 BP 120
IF (J.NE.NPRODS) GO TO 240 BP 121
PRINT 5090, CATX BP 122
ERROR=.TRUE. BP 123
190 DO 230 K=1,7 BP 124
N=NUM(K) BP 125
IF (N.EQ.0) GO TO 230 BP 126
IF (N.GT.MXACCT) GO TO 200 BP 127
IF (MEMBRX(N,1).NE.EXS) GO TO 210 BP 128
200 PRINT 5100, CATX, N BP 129
ERROR=.TRUE. BP 130
GO TO 230 BP 131
210 IF (ORDER(N,J).EQ.QUAN(K)) GO TO 220 BP 132
PRINT 5110, CATX, N BP 133
ERROR=.TRUE. BP 134
220 ORDER(N,J)=QUAN(K+7) BP 135
230 CONTINUE BP 136
GO TO 250 BP 137
240 CONTINUE BP 138
250 CONTINUE BP 139
CALL ERRCHK (6, &290) BP 140
C * READ NOTES TO BE COPIED ONTO BILLING SHEETS BP 141
260 DO 270 I=1,MXNOTE BP 142
READ 5120, (NOTEX(I,J), J=1,8) BP 143
IF (NOTEX(I,1).NE.ZEROSX) GO TO 270 BP 144
NNOTES=I-1 BP 145
GO TO 280 BP 146
270 CONTINUE BP 147
CALL ERRCHK (7, &290) BP 148
NNOTES=MXNOTE BP 149
280 IF (NNOTES.GT.0) NOTES=.TRUE. BP 150
C * STOP IF ERROR(S) DETECTED BP 151
IF (.NOT.ERROR) GO TO 300 BP 152
290 PRINT 5130 BP 153
STOP BP 154
300 PRINT 5140 BP 155
C * COMPUTE SELLING PRICES & PRINT PRICE LIST BP 156
DO 310 I=1,NPRODS BP 157
J=(100.0+FACTOR(I))*PRICE(I)+0.5 BP 158
310 SELL(I)=J/100.0 BP 159
PMAX=(NPRODS-1)/108+1 BP 160
C TO GET 1 OR 2 "WORK" COPIES MAKE THE LAST DIGIT IN THE BP 161
C FOLLOWING STATEMENT 2 OR 3, RESPECTIVELY. BP 162
DO 360 I=1,2 BP 163
LABELX=WORDX(I) BP 164
330 DO 350 P=1,PMAX BP 165
PRINT 5150, DATEX, LABELX, P, PMAX, COOPX BP 166
L1=108*(P-1)+1 BP 167
L2=L1+53 BP 168
DO 350 L=L1,L2 BP 169
IF (L.GT.NPRODS) GO TO 360 BP 170
L3=L+54 BP 171
IF (L3.GT.NPRODS) GO TO 340 BP 172
PRINT 5160, (NAMEX(K,1), NAMEX(K,2), SELL(K), BP 173
2 UNITX(K), PRICE(K), FACTOR(K), K=L,L3,54) BP 174
GO TO 350 BP 175
340 PRINT 5160, NAMEX(L,1), NAMEX(L,2), SELL(L), BP 176
2 UNITX(L), PRICE(L), FACTOR(L) BP 177
350 CONTINUE BP 178
360 CONTINUE BP 179
C * COMPUTE BILLS & STATUS OF ACCOUNTS TOTALS BP 180
DO 370 I=1,MXCAT BP 181
370 PRICE(I)=0.0 BP 182
DO 380 I=1,3 BP 183
380 T1(I)=0.0 BP 184
M=0 BP 185
DO 430 I=1,NACCTS BP 186
TOTAL(I)=0.0 BP 187
K=17 BP 188
DO 390 J=1,NPRODS BP 189
Q=ORDER(I,J) BP 190
IF (Q.EQ.0) GO TO 390 BP 191
K=K+1 BP 192
IF (SELL(J).LT.0.0001) GO TO 390 BP 193
N=100.0*Q*SELL(J)+0.5 BP 194
COST(I,J)=N BP 195
TOTAL(I)=TOTAL(I)+N BP 196
390 CONTINUE BP 197
TOTAL(I)=TOTAL(I)/100.0 BP 198
LINES(I)=K BP 199
IF (NOCATS) GO TO 405 BP 200
CST=BALNCE(I) BP 201
DO 400 J=1,NCATS BP 202
400 CST=CST+SIGN(J)*LIST(J,I) BP 203
NEW(I)=CST-TOTAL(I) BP 204
T1(1)=T1(1)+NEW(I) BP 205
T1(2)=T1(2)+BALNCE(I) BP 206
CUMM(I)=CUMM(I)+TOTAL(I) BP 207
405 T1(3)=T1(3)+TOTAL(I) BP 208
IF (TOTAL(I).NE.0.0) M=M+1 BP 209
IF (NOCATS) GO TO 430 BP 210
IF (NEW(I).LT.DLIM) GO TO 410 BP 211
MCNT(I)=0 BP 212
GO TO 420 BP 213
410 MCNT(I)=MCNT(I)+1 BP 214
420 DO 425 K=1,NCATS BP 215
425 PRICE(K)=PRICE(K)+LIST(K,I) BP 216
C * PRINT STATUS OF ACCOUNTS BP 217
430 K=NACCTS+4 BP 218
IF (.NOT.NOCATS) K=K+(NCATS+3)/4+1 BP 219
L4=NACCTS+2 BP 220
L5=NACCTS+6 BP 221
PMAX=K/54+1 BP 222
C LAST DIGIT OF NEXT STATEMENT SETS NO. OF COPIES; MUST BE > 0. BP 223
DO 490 I=1,2 BP 224
N=1 BP 225
DO 490 P=1,PMAX BP 226
PRINT 5170, DATEX, P, PMAX, COOPX BP 227
IF (.NOT.NOCATS) PRINT 5175, (CATCDX(J), J=1,NCATS) BP 228
PRINT 5180 BP 229
L1=54*(P-1)+1 BP 230
L2=L1+53 BP 231
L3=P*54 BP 232
DO 455 L=L1,L2 BP 233
IF (L.GT.NACCTS) GO TO 460 BP 234
IF (.NOT.NOCATS) GO TO 435 BP 235
PRINT 5185, L,MEMBRX(L,1),MEMBRX(L,2),TOTAL(L) BP 236
GO TO 455 BP 237
435 IF (MCNT(L).LT.NLIM) GO TO 440 BP 238
N1=MCNT(L) BP 239
IF (N1.EQ.0) GO TO 440 BP 240
IF (N1.GT.10) N1=10 BP 241
FLAGX=DIGITX(N1) BP 242
GO TO 450 BP 243
440 FLAGX=BLANKX BP 244
450 PRINT 5190, L, FLAGX, MEMBRX(L,1), MEMBRX(L,2), BP 245
2 NEW(L), BALNCE(L), TOTAL(L), BP 246
3 CUMM(L), (LIST(K,L), K=1,NCATS) BP 247
455 CONTINUE BP 248
GO TO 490 BP 249
460 IF (L4.GT.L3) GO TO 490 BP 250
IF (N.GT.1) GO TO 470 BP 251
N=N+1 BP 252
IF (.NOT.NOCATS) GO TO 465 BP 253
PRINT 5200, M, T1 BP 254
GO TO 470 BP 255
465 PRINT 5200, M, T1, (PRICE(K), K=1,NCATS) BP 256
470 IF (NOCATS) GO TO 490 BP 257
IF (L5.GT.L3) GO TO 490 BP 258
IF (N.GT.2) GO TO 480 BP 259
N=N+1 BP 260
PRINT 5210, DLIM, NLIM BP 261
480 IF (NACCTS+(NCATS+3)/4+6.GT.L3) GO TO 490 BP 262
PRINT 5220, (CATCDX(J), SIGNX(J), BP 263
2 (CTGRYX(J,K), K=1,5), J=1,NCATS) BP 264
490 CONTINUE BP 265
C * PRINT BILLING SHEETS BP 266
DO 560 I=1,NACCTS BP 267
IF (MEMBRX(I,1).EQ.EXS) GO TO 560 BP 268
IF (TOTAL(I).EQ.0.0 .AND. BALNCE(I).EQ.NEW(I)) GO TO 560 BP 269
PRINT 5230, PREFIX, I, MEMBRX(I,1), MEMBRX(I,2), BP 270
2 (INFOX(I,J), J=1,5), COOPX BP 271
IF (LINES(I).LT.18) GO TO 520 BP 272
IF (NOCATS) PRINT 5235, DATEX BP 273
PRINT 5240 BP 274
DO 510 J=1,NPRODS BP 275
IF (ORDER(I,J).EQ.0) GO TO 510 BP 276
IF (SELL(J).GT.0.0001) GO TO 500 BP 277
IF (SELL(J).GT.-0.0001) GO TO 495 BP 278
PRINT 5245, NAMEX(J,1), NAMEX(J,2), BP 279
2 ORDER(I,J), UNITX(J) BP 280
GO TO 510 BP 281
495 PRINT 5250, NAMEX(J,1), NAMEX(J,2), BP 282
2 ORDER(I,J), UNITX(J) BP 283
GO TO 510 BP 284
500 CST=COST(I,J)/100.0 BP 285
PRINT 5260, NAMEX(J,1), NAMEX(J,2), ORDER(I,J), BP 286
2 UNITX(J), SELL(J), CST BP 287
510 CONTINUE BP 288
PRINT 5270, TOTAL(I) BP 289
520 IF (NOCATS) GO TO 545 BP 290
PRINT 5280, DATEX BP 291
PRINT 5290, BALNCE(I) BP 292
DO 540 J=1,NCATS BP 293
IF (LIST(J,I).EQ.0.0) GO TO 540 BP 294
IF (SIGN(J).LT.0.0) GO TO 530 BP 295
PRINT 5300, (CTGRYX(J,K), K=1,5), LIST(J,I) BP 296
GO TO 540 BP 297
530 PRINT 5310, (CTGRYX(J,K), K=1,5), LIST(J,I) BP 298
540 CONTINUE BP 299
PRINT 5320, TOTAL(I), NEW(I) BP 300
545 IF (.NOT.NOTES) GO TO 560 BP 301
PRINT 5330 BP 302
DO 550 J=1,NNOTES BP 303
550 PRINT 5340, (NOTEX(J,K), K=1,8) BP 304
560 CONTINUE BP 305
C * PUNCH NEW MEMBERSHIP FILE CARDS BP 306
PRINT 5350 BP 307
IF (NOCATS) STOP BP 308
DO 570 I=1,NACCTS BP 309
570 PUNCH 5030, PREFIX, I, MEMBRX(I,1), MEMBRX(I,2), BP 310
2 (INFOX(I,J), J=1,5), NEW(I), MCNT(I), CUMM(I) BP 311
STOP BP 312
5000 FORMAT (A3, 7A8, A5, F5.1, F7.2, I2, L2/) BP 313
5010 FORMAT ('0'/'0', 9X, 'ERROR MESSAGES FOR BILLING RUN FOR ', BP 314
2 8A8/'0') BP 315
5020 FORMAT (A2, 1X, A1, 1X, 5A4) BP 316
5030 FORMAT (A3, I3, 1X, 7A8, F7.2, I2, F8.2) BP 317
5040 FORMAT (A2, 1X, 2A8, 1X, A6, 2X, F5.1, F6.3) BP 318
5050 FORMAT (A8/) BP 319
5060 FORMAT (I3, 1X, 19(A2, I2)) BP 320
5065 FORMAT ('0') BP 321
5070 FORMAT (A2, 1X, 7(I3, 1X, F6.5)) BP 322
5071 FORMAT ('0', 25X, 'ACCOUNTING LIST CODE "', A2, BP 323
2 '" WAS USED - THIS CODE WAS NOT DEFINED') BP 324
5072 FORMAT ('0', 25X, 'ACCOUNTING LIST "', A2, '" CONTAINS ', BP 325
2 'ACCOUNT #', I3, ' WHICH IS INACTIVE') BP 326
5073 FORMAT ('0', 25X, 'ACCOUNTING LIST "', A2, '" CONTAINS ', BP 327
2 'ACCOUNT #', I3, ' MORE THAN ONCE') BP 328
5080 FORMAT (A2, 7(I4, 2(1X, I2))) BP 329
5090 FORMAT ('0', 25X, 'AN ORDER CHANGE WAS SUBMITTED FOR ', BP 330
2 'PRODUCT "', A2, '" WHICH IS NOT DEFINED') BP 331
5100 FORMAT ('0', 25X, 'AN ORDER CHANGE FOR PRODUCT "', A2, '" WAS' BP 332
2 , ' ENTERED FOR ACCOUNT #', I3, ' WHICH IS INACTIVE') BP 333
5110 FORMAT ('0', 25X, 'THE ORDER CHANGE FOR PRODUCT "', A2, BP 334
2 '" FOR ACCOUNT #', I3, ' DOES NOT AGREE WITH ', BP 335
3 'THE ORIGINAL ORDER') BP 336
5120 FORMAT (8A8) BP 337
5130 FORMAT ('0'/'0'/10X, 'END OF ERROR LIST -- PROGRAM IS ', BP 338
2 'STOPPING -- CORRECT DATA AND RE-RUN'/'1') BP 339
5140 FORMAT (10X, 'NO ERRORS WERE DETECTED') BP 340
5150 FORMAT ('1'/' PRICE LIST FOR ', A8, 8X, '(', A4, BP 341
2 ' COPY, PAGE', I2, ' OF', I2, ')', 8X, 8A8//'0', BP 342
3 2(6X, 'ITEM', 13X, 'SELL AT UNIT COST', BP 343
4 ' MARKUP (%)', 5X)/) BP 344
5160 FORMAT (2(7X, 2A8, F7.2, 5X, A6, F9.3, F9.1, 7X)) BP 345
5170 FORMAT ('1'/' STATUS OF ACCOUNTS AS OF ', A8, ' (PAGE', BP 346
2 I2, ' OF', I2, ')', 5X, 8A8//'0ACCT NAME', 11X, BP 347
3 'NEW-BAL OLD-BAL ORDER CUMUL') BP 348
5175 FORMAT ('+', 51X, 10(5X, A2, 1X)) BP 349
5180 FORMAT (' ') BP 350
5185 FORMAT (1X, I3, 3X, A8, A5, 16X, F8.2) BP 351
5190 FORMAT (1X, I3, 1X, A1, 1X, A8, A5, 14F8.2) BP 352
5200 FORMAT ('0TOTALS (', I3, ' ORDERS)', 3F8.2, 8X, 10F8.2) BP 353
5210 FORMAT (/'0NOTES: 1 - DIGIT AFTER ACCT. NO. IS NUMBER OF ', BP 354
2 'CONSECUTIVE TIMES BALANCE HAS BEEN BELOW $', F6.2, BP 355
3 '.'/13X, 'DIGITS LESS THAN', I2, ' ARE NOT PRINTED.', BP 356
4 ' "#" IS PRINTED IF DIGIT WOULD BE GREATER THAN 9.') BP 357
5220 FORMAT ('0', 8X, '2 - COLUMN CODES:', T26, 4(2X, A2, 1X, A1, BP 358
2 1X, 5A4), 2(/25X, 4(2X, A2, 1X, A1, 1X, 5A4))) BP 359
5230 FORMAT ('1', A3, I3, ': ', 7A8/'0', 3X, 8A8/) BP 360
5235 FORMAT ('0', 5X, 'ORDER FOR ', A8, ':') BP 361
5240 FORMAT ('0',10X,'ITEM',16X,'QUANTITY UNIT PRICE TOTAL'/) BP 362
5245 FORMAT (11X, 2A8, I5, 2X, A6, 2X, 'NO LONGER AVAILABLE') BP 363
5250 FORMAT (11X, 2A8, I5, 2X, A6, 2X, 'NOT BOUGHT') BP 364
5260 FORMAT (11X, 2A8, I5, 2X, A6, F9.2, F11.2) BP 365
5270 FORMAT ('0', 10X, 'TOTAL OF ORDER', 25X, F10.2) BP 366
5280 FORMAT ('0'/'0', 10X, 'STATEMENT OF ACCOUNT FOR PERIOD ', BP 367
2 'ENDING ',A8/'0',32X,'CHARGES CREDITS BALANCE'/) BP 368
5290 FORMAT (11X, 'OLD BALANCE', 27X, F10.2) BP 369
5300 FORMAT (11X, 5A4, F18.2) BP 370
5310 FORMAT (11X, 5A4, F8.2) BP 371
5320 FORMAT (11X, 'TODAY''S ORDER', F15.2/'0', BP 372
2 10X, 'NEW BALANCE', 27X, F10.2) BP 373
5330 FORMAT ('0'/'0') BP 374
5340 FORMAT (1X, 8A8) BP 375
5350 FORMAT ('1') BP 376
END BP 377
SUBROUTINE ERRCHK (I, *) BP 378
REAL A, WORDS(3,7), ZEROX BP 379
DATA WORDS/'LIST', ' HEA', 'DING', ' MEM', 'BERS', 'HIP ', BP 380
2 ' P', 'RODU', 'CT ', ' ', 'ORDE', 'R ', BP 381
3 'ACCT', 'ING ', 'LIST', 'ORDE', 'R CH', 'ANGE', BP 382
4 ' ', 'NOTE', ' '/, ZEROX/'00'/ BP 383
READ 5000, A BP 384
IF (A.EQ.ZEROX) RETURN BP 385
PRINT 5010, (WORDS(J,I), J=1,3) BP 386
RETURN 1 BP 387
5000 FORMAT (A2) BP 388
5010 FORMAT ('0'/'0', 25X, 'TOO MANY ', 3A4, ' CARDS IN THE DATA') BP 389
END BP 390